PsL Monthly 1993 December/PSL Monthly Shareware CD-ROM (December 1993).iso/prgmming/dos/pascal/gsdbloo.exe/GS_SORT.PAS

Pascal/Delphi Source File | 1992-02-24 | 5.7 KB | 211 lines

unit GS_Sort;
{-----------------------------------------------------------------------------
                           Keyboard Input Routines

       GS_Sort Copyright (c)  Richard F. Griffin

        1 January 1991

       102 Molded Stone Pl
       Warner Robins, GA  31088

       -------------------------------------------------------------
       This unit handles the objects for sorting lists.

   Changes:

------------------------------------------------------------------------------}

interface
{$D-}

type
   GS_Sort_Objt = object
       Ascending   : boolean;
       Gt_Sign,
       Lt_Sign     : integer;
       constructor InitSort(ascnd : boolean);
       procedure   SortDir(ascnd : boolean);
       procedure   Sort(var tabl; clth : word; icnt : longint);
       function    Search(key : string; var tabl; clth : word;
                                icnt : longint) : longint;
       function    Compare(var s1, s2) : integer; virtual;
    end;

function GS_Sort_Compare(var s1,s2) : integer;
procedure GS_Sort_Swap(var s1,s2; len : word);

implementation

type
   buf_type         = array[0..0] of byte;

var
   buffer           : ^buf_type;
   reclen           : word;             { record length }

function GS_Sort_Compare(var s1,s2) : integer;
var
   st1 : string absolute s1;
   st2 : string absolute s2;
   flg : integer;
   eql : boolean;
begin
   eql := st1 = st2;
   Inline(              {Get flag register in flg}
     $9C/                   {  PUSHF           ;Push flag register}
     $59/                   {  POP     CX      ;Get flag register in CX}
     $89/$4E/<flg);         {  MOV     <flg,CX ;Store CX in flg}
   if eql then GS_Sort_Compare := 0
      else if (flg and $0080) = 0 then
         GS_Sort_Compare := 1             {s1 > s2 if sign flag 0}
            else GS_Sort_Compare := -1;   {s1 < s2 if sign flag 1}
end;

procedure GS_Sort_Swap(var s1,s2; len : word);
begin
   inline(
      $1E/          { push ds           ; save DS reg }
      $8B/$8E/len/  { mov cx,[bp+4]     ; CX = len }
      $C5/$B6/s1/   { lds si,[bp+10]    ; DS:SI = var s1 }
      $C4/$BE/s2/   { les di,[bp+6]     ; ES:DI = var s2 }
      $FC/          { cld               ; set forward direction }
      $8A/$04/      { mov al,[SI]       ; get a }
      $8A/$25/      { mov ah,[DI]       ; get b }
      $88/$24/      { mov [SI],ah       ; store a }
      $AA/          { stosb             ; store b }
      $46/          { inc si            ; increment }
      $E2/$F6/      { loop ...          ; continue }
      $1F           { pop ds            ; restore DS reg }
   );
end;

constructor GS_Sort_Objt.InitSort(ascnd : boolean);
begin
   Ascending := ascnd;
   if ascnd then
   begin
      Gt_Sign := 1;
      Lt_Sign := -1;
   end
   else
   begin
      Gt_Sign := -1;
      Lt_Sign := 1;
   end;
end;

procedure GS_Sort_Objt.SortDir(ascnd : boolean);
begin
   Ascending := ascnd;
   if ascnd then
   begin
      Gt_Sign := 1;
      Lt_Sign := -1;
   end
   else
   begin
      Gt_Sign := -1;
      Lt_Sign := 1;
   end;
end;

function GS_Sort_Objt.Compare(var s1,s2) : integer;
var
   st1 : string absolute s1;
   st2 : string absolute s2;
   flg : integer;
   eql : boolean;
begin
   eql := st1 = st2;
   Inline(              {Get flag register in flg}
     $9C/                   {  PUSHF           ;Push flag register}
     $59/                   {  POP     CX      ;Get flag register in CX}
     $89/$4E/<flg);         {  MOV     <flg,CX ;Store CX in flg}
   if eql then Compare := 0
      else if (flg and $0080) = 0 then
         Compare := Gt_Sign            {s1 > s2 if sign flag 0}
            else Compare := Lt_Sign;   {s1 < s2 if sign flag 1}
end;

{----------------------------------------------------------------------}

procedure GS_Sort_Objt.Sort(var tabl; clth : word; icnt : longint);


{ QuickSort algorithm }

   procedure qsort(l,r: integer);
   var
      i,j,x             : integer;
      midpoint          : ^buf_type;       { midpoint value }

   begin
      i := l;
      j := r;
      x := (l + r) div 2;
      getmem(midpoint,reclen);                { allocate midpoint buffer }
      move(buffer^[x*reclen],midpoint^,reclen);  { get midpoint value }
      repeat
         while Compare(buffer^[i*reclen],midpoint^) < 0 do inc(i);
         while Compare(midpoint^,buffer^[j*reclen]) < 0 do dec(j);
         if i <= j then begin
            GS_Sort_Swap(buffer^[i*reclen],buffer^[j*reclen],reclen);
            inc(i);
            dec(j);
         end;
      until i > j;
      freemem(midpoint,reclen);               { deallocate midpoint buffer }
      if l < j then qsort(l,j);
      if i < r then qsort(i,r);
   end;

begin
   buffer := @tabl;
   reclen := clth;
   qsort(0,pred(icnt));
end;


function  GS_Sort_Objt.Search(key : string; var tabl; clth : word;
                                    icnt : longint) : longint;
var
   l,u,i,j          : integer;
   done             : boolean;

begin
   buffer := @tabl;
   l := 0;
   u := icnt;
   done := false;
   while not done do
   begin
      i := (l+u) div 2;                 { compute midpoint of range }
      j := Compare(buffer^[i * clth],key);
      if j=0 then
      begin
         Search := i;
         done := true;
      end else if j<0 then
      begin
         if l=i then
         begin
            Search := -1;
            done := true;
         end else
            l := i;
      end else
      begin
         if u=i then
         begin
            Search := -1;
            done := true;
         end else
            u := i;
      end;
   end;
end;


end.